<<<<<<< HEAD ======= >>>>>>> 2e40262d2bb1fba8e70493c529b4bbee87415dc8 R6 Class

R6 Class

<<<<<<< HEAD

Functions

Expression

z <- rlang::expr(y <- x * 10)
z

y <- x * 10

x <- 4
base::eval(z)
y

[1] 40

Abstract Syntax trees (ASTs)

  • The leaves of the trees are either symbols or constants.
  • Strings and symbols are easily confused, so strings are always surrounded in quotes.
  • The branches of the tree are called objects which represent function calls. The first child is the function that gets called, and the second and subsequent are children that are the arguments to that function.
  • The depth within the tree is determined by the nesting of function calls. This also determines evaluation order, as evaluation proceeds from deepest-to-shallowest, but not guaranteed because of lazy evaluation.
  • infix vs prefix calls:
library(rlang)
library(lobstr)

lobstr::ast(f(x, "y", 1))

█─f ├─x ├─“y” └─1

lobstr::ast(f(g(1, 2), h(3, 4, i())))

█─f ├─█─g │ ├─1 │ └─2 └─█─h ├─3 ├─4 └─█─i

Missing arguments to a function

  • missing() function inside a function can check if an argument’s value comes from the user or from a default
fx <- function(x = 10, y = NULL) {
  list(missing(x), is.null(x), x, missing(y), is.null(y), y)
}

str(fx())

List of 6 $ : logi TRUE $ : logi FALSE $ : num 10 $ : logi TRUE $ : logi TRUE $ : NULL

str(fx(5))

List of 6 $ : logi FALSE $ : logi FALSE $ : num 5 $ : logi TRUE $ : logi TRUE $ : NULL

str(fx(5, 6))

List of 6 $ : logi FALSE $ : logi FALSE $ : num 5 $ : logi FALSE $ : logi FALSE $ : num 6

args(fx)

function (x = 10, y = NULL) NULL

lapply(list(1, NULL, 2, NULL), function(x = NULL) is.null(x))

[[1]] [1] FALSE

[[2]] [1] TRUE

[[3]] [1] FALSE

[[4]] [1] TRUE

sapply(list(1, NULL, 2, NULL), function(x = NULL) is.null(x))

[1] FALSE TRUE FALSE TRUE

sapply(list(1, NULL, 2, NULL), function(x) missing(x))

[1] FALSE FALSE FALSE FALSE

Capture the current call

  • sys.call() captures exactly what the user feeds the function (some of them positional)
  • match.call() captures named arguments
f <- function(a = 1, b = 2, c = 3){
  list(sys = sys.call(), match = match.call())
}

f(a = 5, 6)

$sys f(a = 5, 6)

$match f(a = 5, b = 6)

f <- function(a = 1, b = 2, c =3){
  print(match.call())
  print(as.list(match.call()))
  s <- do.call("sum", as.list(match.call())[-1L])
  print(s)
}

f(1, 2, 3)

f(a = 1, b = 2, c = 3) [[1]] f

$a [1] 1

$b [1] 2

$c [1] 3

[1] 6

fx <- function(a = 1, b = 2, c = 3, ...){
  all_arguments <- c(as.list(environment()), list(...))
  print("All arguments including default arguments:")
  print(all_arguments)
  print("----------------")
  print("match.call(): ")
  print(match.call())
  print("")
  print("----------------")
  print("match.call() as list:")
  print(as.list(match.call()))
  print("")
  print("----------------")
  print("match.call(expand.dots = TRUE) as list:")
  print(as.list(match.call(expand.dots = TRUE)))
  print("")
  print("----------------")
  print("list(...):")
  print(list(...))
  print("----------------")
  s <- do.call("sum", as.list(match.call())[-1L])
  print(s)
}

value <- 33
fx(a = value, d = 4, f = 5)

[1] “All arguments including default arguments:” $a [1] 33

$b [1] 2

$c [1] 3

$d [1] 4

$f [1] 5

[1] “—————-” [1] “match.call():” fx(a = value, d = 4, f = 5) [1] "" [1] “—————-” [1] “match.call() as list:” [[1]] fx

$a value

$d [1] 4

$f [1] 5

[1] "" [1] “—————-” [1] “match.call(expand.dots = TRUE) as list:” [[1]] fx

$a value

$d [1] 4

$f [1] 5

[1] "" [1] “—————-” [1] “list(…):” $d [1] 4

$f [1] 5

[1] “—————-” [1] 42

call() and do.call()

  • call() returns a call object with its name and arguments
  • do.call() evaluates the call immediately
call("sum", list(1, 2))

sum(list(1, 2))

base::eval(call("sum", c(1, 2)))

[1] 3

do.call("sum", list(1, 2))

[1] 3

R6 Object RR

library(Wu)
library(R6)
library(sloop)
library(epitools)

dt <- data.table(
  outcome = sample(c(0,1), 100, replace = TRUE)
, treatment = factor(rep(c("case", "control"), 50), levels = c("case", "control"))
, sex = factor(sample(c("F", "M"), 100, replace = TRUE), levels = c("F", "M"))
)


RR <- R6Class(
  "RR"
, list(binary = NA
     , groups = NA
     , data = NULL
     , groups_nlevels = NULL
     , tables = NULL
     , freqs = NULL
     , ors_str = NULL
     , oddsratios = NULL
     , riskratios = NULL
     , fx_or = function(x) epitools::epitab(x, method = "oddsratio", oddsratio = "wald")
     , fx_rr = function(x) epitools::epitab(x, method = "riskratio", oddsratio = "wald")
     , initialize = function(binary, groups, data) {
       self$binary <- binary
       self$groups <- groups
       vars <- c(binary, groups)
       self$data <- data[, ..vars]
       self$groups_nlevels <- lapply(groups, function(x) length(levels(self$data[[x]])))
       self$tables <- lapply(self$groups, function(x) table(self$data[[x]], self$data[[self$binary]]))
       self$freqs <- lapply(self$groups, function(x) Wu::tab_freq(self$binary, x, self$data))
       self$ors_str <- Wu::get_ors(self$binary, self$groups, self$data)
       self$oddsratios <- lapply(self$tables, self$fx_or)
       self$riskratios <- lapply(self$tables, self$fx_rr)
     }
     ))



RR1 <- RR$new(binary = "outcome", groups = c("treatment", "sex"), data = dt)

otype(RR1)

[1] “R6”

str(RR1)

Classes ‘RR’, ‘R6’ Public: binary: outcome clone: function (deep = FALSE) data: data.table, data.frame freqs: list fx_or: function (x) fx_rr: function (x) groups: treatment sex groups_nlevels: list initialize: function (binary, groups, data) oddsratios: list ors_str: data.table, data.frame riskratios: list tables: list

class(RR1$data)

[1] “data.table” “data.frame”

RR1$tables

[[1]]

       0  1

case 21 29 control 27 23

[[2]]

 0  1

F 28 24 M 20 28

RR1$freqs

[[1]] predictor label level coef.name N n n.0 n.1 n.str rate.0 rate.1 1: treatment case treatmentcase 100 50 21 29 50/100 0.42 0.58 2: treatment control treatmentcontrol 100 50 27 23 50/100 0.54 0.46 rate.str.0 rate.str.1 odds.0 odds.1 odds.str.0 odds.str.1 1: 42.0%(21/50) 58.0%(29/50) 0.7241379 1.3809524 0.72(21/29) 1.38(29/21) 2: 54.0%(27/50) 46.0%(23/50) 1.1739130 0.8518519 1.17(27/23) 0.85(23/27)

[[2]] predictor label level coef.name N n n.0 n.1 n.str rate.0 rate.1 1: sex F sexF 100 52 28 24 52/100 0.5384615 0.4615385 2: sex M sexM 100 48 20 28 48/100 0.4166667 0.5833333 rate.str.0 rate.str.1 odds.0 odds.1 odds.str.0 odds.str.1 1: 53.8%(28/52) 46.2%(24/52) 1.1666667 0.8571429 1.17(28/24) 0.86(24/28) 2: 41.7%(20/48) 58.3%(28/48) 0.7142857 1.4000000 0.71(20/28) 1.40(28/20)

RR1$ors

NULL

RR1$groups_levels

NULL

RR1$groups_nlevels

[[1]] [1] 2

[[2]] [1] 2

RR1$oddsratios

[[1]] [[1]]$tab

       0     p0  1        p1 oddsratio    lower    upper   p.value

case 21 0.4375 29 0.5576923 1.0000000 NA NA NA control 27 0.5625 23 0.4423077 0.6168582 0.279854 1.359688 0.3169521

[[1]]$measure [1] “wald”

[[1]]$conf.level [1] 0.95

[[1]]$pvalue [1] “fisher.exact”

[[2]] [[2]]$tab

 0        p0  1        p1 oddsratio     lower  upper   p.value

F 28 0.5833333 24 0.4615385 1.000000 NA NA NA M 20 0.4166667 28 0.5384615 1.633333 0.7401447 3.6044 0.2371371

[[2]]$measure [1] “wald”

[[2]]$conf.level [1] 0.95

[[2]]$pvalue [1] “fisher.exact”

RR1$riskratios

[[1]] [[1]]$tab

       0   p0  1   p1 riskratio     lower    upper   p.value

case 21 0.42 29 0.58 1.0000000 NA NA NA control 27 0.54 23 0.46 0.7931034 0.5413588 1.161915 0.3169521

[[1]]$measure [1] “wald”

[[1]]$conf.level [1] 0.95

[[1]]$pvalue [1] “fisher.exact”

[[2]] [[2]]$tab

 0        p0  1        p1 riskratio     lower    upper   p.value

F 28 0.5384615 24 0.4615385 1.000000 NA NA NA M 20 0.4166667 28 0.5833333 1.263889 0.8655207 1.845612 0.2371371

[[2]]$measure [1] “wald”

[[2]]$conf.level [1] 0.95

[[2]]$pvalue [1] “fisher.exact”

=======

R6 Object

library(Wu)
library(R6)
library(sloop)
library(epitools)

dt <- data.table(
  outcome = sample(c(0,1), 100, replace = TRUE)
, treatment = factor(rep(c("case", "control"), 50), levels = c("case", "control"))
, sex = factor(sample(c("F", "M"), 100, replace = TRUE), levels = c("F", "M"))
)


RR <- R6Class(
  "RR"
, list(binary = NA
     , groups = NA
     , data = NULL
     , groups_nlevels = NULL
     , tables = NULL
     , freqs = NULL
     , ors_str = NULL
     , oddsratios = NULL
     , riskratios = NULL
     , fx_or = function(x) epitools::epitab(x, method = "oddsratio", oddsratio = "wald")
     , fx_rr = function(x) epitools::epitab(x, method = "riskratio", oddsratio = "wald")
     , initialize = function(binary, groups, data) {
       self$binary <- binary
       self$groups <- groups
       vars <- c(binary, groups)
       self$data <- data[, ..vars]
       self$groups_nlevels <- lapply(groups, function(x) length(levels(self$data[[x]])))
       self$tables <- lapply(self$groups, function(x) table(self$data[[x]], self$data[[self$binary]]))
       self$freqs <- lapply(self$groups, function(x) Wu::tab_freq(self$binary, x, self$data))
       self$ors_str <- Wu::get_ors(self$binary, self$groups, self$data)
       self$oddsratios <- lapply(self$tables, self$fx_or)
       self$riskratios <- lapply(self$tables, self$fx_rr)
     }
     ))



RR1 <- RR$new(binary = "outcome", groups = c("treatment", "sex"), data = dt)




add_copy_icon <- function(id){
  txt <- paste0('<button type=\"button\" onclick=\"selectElementContents( document.getElementById('
              , '\''
              , id
              , '\''
              , ') );\">Copy Table</button>')
  cat(txt)
}

add_copy_icon("t1")
Table of Odds Ratio
0 p0 1 p1 oddsratio lower upper p.value
F 23 0.4791667 25 0.4807692 1.0000 NA NA NA
M 25 0.5208333 27 0.5192308 0.9936 0.4530886 2.178914 1

Environment

R version 4.1.0 (2021-05-18) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04.2 LTS

Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0

locale: [1] LC_CTYPE=C.UTF-8 LC_NUMERIC=C LC_TIME=C.UTF-8
[4] LC_COLLATE=C.UTF-8 LC_MONETARY=C.UTF-8 LC_MESSAGES=C.UTF-8
[7] LC_PAPER=C.UTF-8 LC_NAME=C LC_ADDRESS=C
[10] LC_TELEPHONE=C LC_MEASUREMENT=C.UTF-8 LC_IDENTIFICATION=C

attached base packages: [1] stats graphics grDevices utils datasets methods base

other attached packages: [1] epitools_0.5-10.1 sloop_1.0.1 R6_2.5.0
[4] Wu_0.0.0.9000 flexdashboard_0.5.2 lme4_1.1-27.1
[7] Matrix_1.3-4 mgcv_1.8-36 nlme_3.1-152
[10] png_0.1-7 scales_1.1.1 nnet_7.3-16
[13] labelled_2.8.0 kableExtra_1.3.4 plotly_4.9.4.1
[16] gridExtra_2.3 ggplot2_3.3.5 DT_0.18
[19] tableone_0.13.0 magrittr_2.0.1 lubridate_1.7.10
[22] dplyr_1.0.7 plyr_1.8.6 data.table_1.14.0
[25] rmdformats_1.0.2 knitr_1.33

loaded via a namespace (and not attached): [1] httr_1.4.2 sass_0.4.0 tidyr_1.1.3 jsonlite_1.7.2
[5] viridisLite_0.4.0 splines_4.1.0 bslib_0.2.5.1 assertthat_0.2.1 [9] highr_0.9 yaml_2.2.1 pillar_1.6.1 lattice_0.20-44
[13] glue_1.4.2 digest_0.6.27 rvest_1.0.0 minqa_1.2.4
[17] colorspace_2.0-2 htmltools_0.5.1.1 survey_4.0 pkgconfig_2.0.3
[21] haven_2.4.1 bookdown_0.22 purrr_0.3.4 webshot_0.5.2
[25] svglite_2.0.0 tibble_3.1.2 generics_0.1.0 ellipsis_0.3.2
[29] withr_2.4.2 klippy_0.0.0.9500 lazyeval_0.2.2 survival_3.2-11
[33] crayon_1.4.1 evaluate_0.14 fansi_0.5.0 MASS_7.3-54
[37] forcats_0.5.1 xml2_1.3.2 tools_4.1.0 hms_1.1.0
[41] mitools_2.4 lifecycle_1.0.0 stringr_1.4.0 munsell_0.5.0
[45] compiler_4.1.0 jquerylib_0.1.4 systemfonts_1.0.2 rlang_0.4.11
[49] grid_4.1.0 nloptr_1.2.2.2 rstudioapi_0.13 htmlwidgets_1.5.3 [53] crosstalk_1.1.1 rmarkdown_2.9 boot_1.3-28 gtable_0.3.0
[57] DBI_1.1.1 performance_0.7.2 utf8_1.2.1 insight_0.14.2
[61] stringi_1.6.2 Rcpp_1.0.7 vctrs_0.3.8 tidyselect_1.1.1 [65] xfun_0.24

>>>>>>> 2e40262d2bb1fba8e70493c529b4bbee87415dc8